home *** CD-ROM | disk | FTP | other *** search
/ Trading on the Edge / Trading On The Edge - CD-ROM Toolkit (Wayzata Technology)(2031)(1994).bin / pc / mac_file / vendor_d / ga_softw / ooga / pop-meth.lis < prev    next >
Lisp/Scheme  |  1991-02-03  |  26KB  |  767 lines
  1. ;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
  2. #||
  3.             RESTRICTED RIGHTS LEGEND
  4.                     
  5.  Use, duplication, or disclosure by the Government is subject to
  6.  restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  7.  Technical Data and Computer Software Clause at 52.227-7013 of the DOD
  8.  FAR Supplement.
  9.                     
  10.                 TSP (The Software Partnership)
  11.                 P.O. Box 991
  12.                 Melrose, MA 02176
  13.                     
  14.       Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
  15. ||#
  16.  
  17. (in-package :ooga)
  18.  
  19. ;;; This file contains methods related to the population module.
  20.  
  21. ;;; **********************************************************************
  22. ;;; Variables used to control population member recycling...
  23. ;;; 
  24.  
  25. (defvar *OLD-MEMBERS* nil "List of members to recycle")
  26.  
  27. (defvar *RECYCLE-MEMBERS-FLAG* t "Whether to recycle")
  28.  
  29. (defvar *RECYCLE-TALLY* 0 "Number of objects recycled since last reset")
  30.  
  31.  
  32. ;************************************************************
  33.  
  34. ;     POPULATION MEMBER
  35.  
  36. ;;; Evaluation-better-p determines whether the GA will be
  37. ;;; maximizing or minimizing the evaluation function.  The
  38. ;;; default is maximizing.  This method should be defined for
  39. ;;; the population member class of the user's GA is minimization
  40. ;;; is required.  (See the how-to-examples file for examples of
  41. ;;; such definition.)
  42.  
  43. (defgeneric EVALUATION-BETTER-P (member1 member2)
  44.   #-:pcl
  45.   (:documentation "Compares the two population members and returns non-NIL if member1's
  46. evaluation is greater than member2's."))
  47.  
  48.  
  49. (defmethod EVALUATION-BETTER-P ((member1 t) (member2 t)) t)
  50.  
  51.  
  52. (defmethod EVALUATION-BETTER-P ((member1 population-member)
  53.                 (member2 population-member))
  54.   "Default behavior is to treat greater evaluation values as better."
  55.   (> (evaluation member1) (evaluation member2)))
  56.  
  57.  
  58. ;************************************************************
  59.  
  60. ;       REPRESENTATION TECHNIQUE
  61.  
  62.  
  63. (defmethod INITIALIZE-FOR-RUN ((technique representation-technique))
  64.   t)
  65.  
  66.  
  67.  
  68. ;************************************************************
  69.  
  70. ;    INITIALIZATION TECHNIQUE
  71.  
  72.  
  73. (defmethod INITIALIZE-FOR-RUN ((technique initialization-technique))
  74.   t)
  75.  
  76.  
  77. ;;; Make initial population is a major method in GA runs.
  78. ;;; It builds up a list of initial population members until the
  79. ;;; list equals the population size desired.  First, it uses any
  80. ;;; seeds given it by other processes or generated by itself.
  81. ;;; Then it creates population members to fill out the initial
  82. ;;; population list.
  83.  
  84. ;;; This is a technique that users may wish to tailor for their
  85. ;;; own use.  Note that if the user uses the seeds option, the
  86. ;;; user is responsible for resetting the seeds slot before new
  87. ;;; runs.
  88.  
  89. (defmethod MAKE-INITIAL-POPULATION 
  90.   ((initialization-technique initialization-technique))
  91.   "Create the initial population from seeds and new members."
  92.   (setf (initial-population initialization-technique)
  93.     (loop for seed in (seeds initialization-technique)
  94.           collect (seed-population-member initialization-technique seed)))
  95.   (create-initial-population initialization-technique))
  96.  
  97.  
  98. (defmethod SEED-POPULATION-MEMBER
  99.        ((initialization-technique initialization-technique) seed)
  100.   "Return a population member with the seed as its chromosome."
  101.   (let ((new-member
  102.       (create-population-member
  103.         initialization-technique
  104.         (representation-technique
  105.           (population-module
  106.         initialization-technique)))))
  107.     (setf (chromosome new-member) seed)
  108.     new-member))
  109.  
  110.  
  111. (defmethod CREATE-INITIAL-POPULATION
  112.        ((initialization-technique initialization-technique))
  113.   "Fill the initial population slot with a list of population
  114. members as long as the population size."
  115.   (setf (initial-population initialization-technique)
  116.     (firstn
  117.       (population-size
  118.         (population-module initialization-technique))
  119.       (append (initial-population initialization-technique)
  120.           (loop for n from (1+ (length (initial-population
  121.                          initialization-technique)))
  122.                   to (population-size
  123.                    (population-module
  124.                      initialization-technique))
  125.             with representation-technique =
  126.               (representation-technique
  127.                 (population-module
  128.                   initialization-technique))
  129.             collect (create-population-member
  130.                   initialization-technique
  131.                   representation-technique t))))))
  132.  
  133.  
  134. ;;; This method may generate unneccessary garbage and require
  135. ;;; excess overhead.  If the user is not maintaining genealogies
  136. ;;; or other pointers from parents to children, consider loading
  137. ;;; the RECYCLE-POPULATION file to cut down on object creation.
  138.  
  139. (defun GET-NEW-MEMBER (member-class)
  140.   "Return a member of the class.  If there is one to recycle, recycle it.
  141.    Otherwise, make a new one."
  142.   (if *recycle-members-flag*
  143.       (let ((old-member (car *old-members*)))
  144.     (if (eq (class-name (class-of old-member)) member-class)
  145.         (progn (reset old-member)
  146.            (setf *old-members* (cdr *old-members*))
  147.            (setf *recycle-tally* (1+ *recycle-tally*))
  148.            old-member)
  149.         (make-instance member-class)))
  150.       (make-instance member-class)))
  151.  
  152.  
  153. ;;; Create a population member.  If the initialize? flag is t,
  154. ;;; generate a random binary chromosome.
  155.  
  156. (defmethod CREATE-POPULATION-MEMBER
  157.        ((initialization-technique random-binary-initialization)
  158.         (representation-technique binary-representation)
  159.         &optional (initialize? nil))
  160.   (let ((new-member (get-new-member
  161.               (population-member-class initialization-technique))))
  162.     (if initialize? (setf (chromosome new-member)
  163.               (create-random-bit-string
  164.                 (bit-string-length representation-technique))))
  165.     new-member))
  166.  
  167.  
  168. ;;; Create a population member.  If the initialize? flag is t,
  169. ;;; generate a random real number chromosome.
  170.  
  171. (defmethod CREATE-POPULATION-MEMBER
  172.        ((initialization-technique random-real-number-initialization)
  173.         (representation-technique real-number-representation)
  174.         &optional (initialize? nil))
  175.   (let ((new-member (get-new-member
  176.               (population-member-class initialization-technique))))
  177.     (if initialize? (setf (chromosome new-member)
  178.               (create-chromosome representation-technique)))
  179.     new-member))
  180.  
  181.  
  182. ;;; Create a list of real numbers using the real number specs.
  183.  
  184. (defmethod CREATE-CHROMOSOME
  185.        ((representation-technique real-number-representation))
  186.   (loop repeat (chromosome-length representation-technique)
  187.     for specs = (real-number-specs representation-technique)
  188.        then (if (cdr specs) (cdr specs) specs)
  189.     for spec  = (car specs)
  190.     collect (make-random-value
  191.           (first spec)
  192.           (second spec)
  193.           (if (third spec) (third spec) nil))))
  194.  
  195.  
  196. ;;; Create a population member.  If the initialize? flag is t,
  197. ;;; generate a random permutation chromosome.
  198.  
  199. (defmethod CREATE-POPULATION-MEMBER
  200.        ((initialization-technique random-permutation)
  201.         (representation-technique permuted-list)
  202.         &optional (initialize? nil))
  203.   (let ((new-member (get-new-member
  204.               (population-member-class initialization-technique))))
  205.     (if initialize? (setf (chromosome new-member)
  206.               (nscramble (copy-list
  207.                       (list-to-permute
  208.                         initialization-technique)))))
  209.     new-member))
  210.  
  211.  
  212. ;;; Note that evaluators for random-permutation initialization
  213. ;;; techniques must respond to the LIST-TO-PERMUTE message.
  214.  
  215. (defmethod INITIALIZE-FOR-RUN ((initialization-technique random-permutation))
  216.   "Get the list to permute from the evaluator."
  217.   (setf (list-to-permute initialization-technique)
  218.     (list-to-permute
  219.       (evaluator
  220.         (evaluation-module
  221.           (ga (population-module initialization-technique)))))))
  222.  
  223.  
  224.  
  225.  
  226. ;************************************************************
  227.  
  228. ;     PARENT SELECTION TECHNIQUE
  229.  
  230.  
  231. (defmethod INITIALIZE-FOR-RUN ((technique parent-selection-technique))
  232.   t)
  233.  
  234.  
  235. ;;; Choose a parent using the roulette wheel method.
  236.  
  237. (defmethod GET-PARENT ((roulette-wheel roulette-wheel-parent-selection))
  238.   "Get a population member by evaluations"
  239.   (let ((population-module (population-module roulette-wheel)))
  240.     (get-associated-linked-list-element
  241.       (first-member population-module)
  242.       (fitness-list population-module)
  243.       (random (apply '+ (fitness-list population-module))))))  ;; CAN CACHE TOTAL
  244.  
  245.  
  246.  
  247.  
  248. ;************************************************************
  249.  
  250. ;     DELETION TECHNIQUE
  251.  
  252.  
  253. (defmethod INITIALIZE-FOR-RUN ((technique deletion-technique))
  254.   t)
  255.  
  256.  
  257.  
  258.  
  259. ;************************************************************
  260.  
  261. ;     REPRODUCTION TECHNIQUE
  262.  
  263.  
  264. (defmethod INITIALIZE-FOR-RUN ((technique reproduction-technique))
  265.   t)
  266.  
  267.  
  268. ;;; Reset the duplicate tally.  Set the number of allowed
  269. ;;; duplicates to equal the number of desired trials.
  270.  
  271. (defmethod INITIALIZE-FOR-RUN :AFTER
  272.        ((reproduction-technique steady-state-without-duplicates))
  273.   (setf (duplicate-tally reproduction-technique) 0
  274.     (maximum-duplicates reproduction-technique)
  275.     (desired-trials
  276.            (population-module reproduction-technique))))
  277.  
  278.  
  279. ;************************************************************
  280.  
  281. ;    FITNESS TECHNIQUE
  282.  
  283.  
  284.  
  285. (defmethod INITIALIZE-FOR-RUN ((fitness-technique fitness-is-evaluation))
  286.   t)
  287.  
  288.  
  289. ;;; Set the fitness list to equal the list of population member
  290. ;;; evaluations.
  291.  
  292. (defmethod UPDATE-FITNESS-LIST ((fitness-technique fitness-is-evaluation))
  293.   (setf (fitness-list (population-module fitness-technique))
  294.     (loop for evaluation in
  295.           (evaluations (population-module fitness-technique))
  296.           collect (max 0 evaluation))))
  297.  
  298.  
  299. ;;; Set the fitness list to equal a linearly descending list of
  300. ;;; values.
  301.  
  302. (defmethod INITIALIZE-FOR-RUN ((fitness-technique linear-normalization))
  303.   (setf (fitness-list (population-module fitness-technique))
  304.     (loop repeat (population-size (population-module fitness-technique))
  305.           for value = (max (starting-value fitness-technique)
  306.                    (minimum-value fitness-technique))
  307.             then (max (- value (decrement fitness-technique))
  308.                   (minimum-value fitness-technique))
  309.           collect value)))
  310.  
  311.  
  312. ;;; A linear fitness list doesn't have to be updated when
  313. ;;; members are added or deleted.
  314.  
  315. (defmethod UPDATE-FITNESS-LIST ((fitness-technique linear-normalization))
  316.   t)
  317.  
  318.  
  319. ;************************************************************
  320.  
  321. ;     POPULATION PARAMETERIZATION TECHNIQUES
  322.  
  323. ;;; Begin the interpolation.
  324.  
  325. (defmethod INITIALIZE-FOR-RUN ((technique interpolate-fitness-decrement))
  326.   (setf (decrement (fitness-technique (population-module technique)))
  327.     (car (interpolation-specs technique))))
  328.  
  329.  
  330. ;;; Interpolate the fitness decrement parameter periodically.
  331. ;;; If parameter is modified, force the recomputation of the
  332. ;;; list of fitnesses.
  333.  
  334. ;;; NOTE:  THIS TECHNIQUE SHOULD BE USED ONLY WITH THE LINEAR
  335. ;;; NORMALIZATION FITNESS TECHNIQUE.
  336.  
  337. (defmethod MODIFY-PARAMETERS
  338.        ((technique interpolate-fitness-decrement)
  339.         portion-completed size-of-interval)
  340.   (if (even-multiple portion-completed (interpolation-interval technique))
  341.       (progn
  342.     (setf (decrement (fitness-technique (population-module technique)))
  343.       (interpolate 0
  344.                (car (interpolation-specs technique))
  345.                size-of-interval
  346.                (cadr (interpolation-specs technique))
  347.                portion-completed))
  348.     (initialize-for-run
  349.       (fitness-technique (population-module technique))))))
  350.  
  351.  
  352. ;************************************************************
  353.  
  354. ;    POPULATION MODULE
  355.  
  356.  
  357. ;;; Set up pointers and drive initialization.
  358.  
  359. (defmethod INITIALIZE-FOR-RUN
  360.        ((population-module basic-population-module))
  361.   (setf (population-module (representation-technique population-module))
  362.     population-module
  363.     (population-module (initialization-technique population-module))
  364.     population-module
  365.     (population-module (fitness-technique population-module))
  366.     population-module 
  367.     (Population-module (parent-selection-technique population-module))
  368.     population-module
  369.     (population-module (deletion-technique population-module))
  370.     population-module
  371.     (population-module (reproduction-technique population-module))
  372.     population-module)
  373.   (loop for technique in (parameterization-techniques population-module)
  374.     do (setf (population-module technique) population-module)
  375.        (initialize-for-run technique))
  376.   (setf (first-member population-module) nil
  377.     (last-member population-module) nil)
  378.   (setf (stop-run? population-module) nil)
  379.   (initialize-for-run (representation-technique population-module))
  380.   (initialize-for-run (initialization-technique population-module))
  381.   (initialize-for-run (fitness-technique population-module))
  382.   (initialize-for-run (parent-selection-technique population-module))
  383.   (initialize-for-run (deletion-technique population-module))
  384.   (initialize-for-run (reproduction-technique population-module))
  385.   )
  386.  
  387.  
  388. ;;;    POPULATION INITIALIZATION AND MAINTENANCE
  389.  
  390.  
  391. ;;; Do bookkeeping.  Create the initial population.  Update the
  392. ;;; fitness list.
  393.  
  394. (defmethod INITIALIZE-POPULATION
  395.        ((population-module basic-population-module))
  396.   (setf    (current-index population-module) 0)
  397.   (setf (first-member population-module) nil)
  398.   (setf (last-member population-module) nil)
  399.   (make-initial-population (initialization-technique population-module))
  400.   (loop for new-member in (initial-population
  401.                 (initialization-technique population-module))
  402.     do (prepare-and-install-member population-module new-member))
  403.   (update-fitness-list (fitness-technique population-module)))
  404.  
  405.  
  406. ;;; Set the member index and evaluation.  Increment the current
  407. ;;; index counter.  Install the member in the population.
  408. (defmethod PREPARE-AND-INSTALL-MEMBER
  409.        ((population-module basic-population-module) new-member)
  410.   (setf (current-index population-module) (1+ (current-index population-module)))
  411.   (setf (index new-member) (current-index population-module))
  412.   (setf (evaluation new-member)
  413.     (evaluate-member (evaluation-module
  414.                (ga population-module)) new-member))
  415.   (install-member population-module new-member))
  416.  
  417.  
  418. ;;; Delete population members to make room for the new members.
  419. ;;; Insert the new members in the population.  Update the
  420. ;;; fitness list.
  421.  
  422. (defmethod INSERT-POPULATION-MEMBERS
  423.        ((population-module basic-population-module) new-members)
  424.   (delete-population-members
  425.     (deletion-technique population-module) new-members)
  426.   (loop for member in new-members
  427.     do (prepare-and-install-member population-module member))
  428.   (update-fitness-list (fitness-technique population-module)))
  429.  
  430.  
  431. ;;; Nothing special here.
  432.  
  433.  
  434.  
  435. ;;; Delete all population members.  Recycle all members unless elitism is
  436. ;;; being used.
  437.  
  438. (defmethod DELETE-POPULATION-MEMBERS
  439.        ((delete-all delete-all) new-members)
  440.   (declare (ignore new-members))
  441.   (setf *old-members*
  442.     ;;There is a bit of a kludge here...
  443.     (append (if (eq (class-name (class-of
  444.                       (reproduction-technique
  445.                     (population-module delete-all))))
  446.             'generational-replacement-with-elitism)
  447.             (cdr (population (population-module delete-all)))
  448.             (population (population-module delete-all)))
  449.         *old-members*))
  450.   (setf (first-member (population-module delete-all)) nil
  451.     (last-member (population-module delete-all)) nil))
  452.  
  453.  
  454. ;;; Delete the last population members.
  455.  
  456. (defmethod DELETE-POPULATION-MEMBERS
  457.        ((delete-last delete-last) new-members)
  458.   (if new-members
  459.   (loop with population-module = (population-module delete-last)
  460.     for n below (length new-members)
  461.     for population-member = (last-member population-module)
  462.         then (predecessor population-member)
  463.     finally (end-at-member population-module population-member))))
  464.  
  465.  
  466.  
  467. (defmethod END-AT-MEMBER ((population-module basic-population-module) member)
  468.   "Cut pointers to the population members that are successors to
  469. the given member."
  470.   (let ((old-members (loop for old-member = (successor member)
  471.                    then (successor old-member)
  472.                    until (null old-member)
  473.                    collect old-member)))
  474.     (setf *old-members*
  475.           (append old-members *old-members*)))
  476.   (let ((predecessor (predecessor member)))
  477.     (if predecessor (setf (successor predecessor) nil
  478.             (predecessor member) nil))
  479.     (setf (last-member population-module) predecessor)))
  480.  
  481.  
  482.  
  483. (defmethod SPLICE-OUT-MEMBER
  484.        ((population-module basic-population-module) member)
  485.   "Splice the member out of the population"
  486.   (if (null member) (format *standard-output* "~%~%NULL MEMBER"))
  487.   (let ((predecessor (predecessor member))
  488.     (successor (successor member)))
  489.     (when predecessor
  490.       (setf (successor predecessor) successor))
  491.     (when successor
  492.       (setf (predecessor successor) predecessor))
  493.     (unless predecessor (setf (first-member population-module) successor))
  494.     (unless successor (setf (last-member population-module) predecessor))
  495.     (setf (population-module member) nil)
  496.     (if (null member) nil    ;;; Make member recyclable
  497.       (setf *old-members* (cons member *old-members*)))
  498.     ))
  499.  
  500.  
  501. (defmethod INSTALL-MEMBER
  502.        ((population-module basic-population-module) member)
  503.   "Splice the member into the population.  Check to see whether
  504. parameters should be interpolated."
  505.   (splice-in-member population-module member
  506.             (first-member-not-better-than population-module member))
  507.   (interpolate-parameters population-module))
  508.  
  509.  
  510. (defmethod INTERPOLATE-PARAMETERS
  511.        ((population-module basic-population-module))
  512.   "Drive calls to parameterization techniques after population
  513. has been initialized."
  514.   (if (>= (current-index population-module)
  515.       (population-size population-module))
  516.       (progn
  517.       (loop for technique in
  518.         (append (parameterization-techniques population-module)
  519.             (parameterization-techniques
  520.               (reproduction-module (ga population-module))))
  521.         do (modify-parameters
  522.          technique
  523.          (- (current-index population-module)   ;;;how far in
  524.             (population-size population-module))
  525.          (- (desired-trials population-module)  ;;; size of interval
  526.             (population-size population-module)))))))
  527.  
  528.  
  529. (defmethod SPLICE-IN-MEMBER
  530.        ((population-module basic-population-module) member successor)
  531.   "Insert the member into its place (before SUCCESSOR).  
  532.    If it's the first or last pop member,
  533.    set the appropriate population module slot.
  534.    The first member to be inserted becomes both first and last population member."
  535.   (let ((predecessor (if successor (predecessor successor) nil)))
  536.   (link population-module
  537.     (if successor (predecessor successor)
  538.         (last-member population-module))
  539.     member
  540.     successor)
  541.   (if successor
  542.       (unless predecessor
  543.       (setf (first-member population-module) member))
  544.       (progn (setf (last-member population-module) member)
  545.          (if (null (first-member population-module))
  546.                (setf (first-member population-module) member))))))
  547.  
  548.  
  549. (defmethod FIRST-MEMBER-NOT-BETTER-THAN
  550.        ((population-module basic-population-module) new-member)
  551.   "Returns the first individual in the population with an evaluation not better
  552.    than NEW-MEMBER.
  553.    It will return NIL if MEMBER is worse than all others."
  554.   (loop for current-member = (first-member population-module)
  555.     then (successor current-member)
  556.     until (null current-member)
  557.     do (if (not (evaluation-better-p current-member new-member))
  558.            (return current-member))
  559.     finally (return nil)))
  560.  
  561.  
  562. ;************************************************************
  563.  
  564. ;;;    EVOLVE:  IMPORTANT DRIVER FUNCTION
  565.  
  566. ;;; Evolve causes the GA to generate new population members
  567. ;;; after the population has been initialized.  This function
  568. ;;; continues until a stop run test is passed.  If information
  569. ;;; about the reason for stopping the run has been given, the
  570. ;;; method displays it.
  571.  
  572. (defmethod EVOLVE ((population-module basic-population-module))
  573.   (loop until (terminate-run-test population-module)
  574.     with reproduction-module = (reproduction-module (ga population-module))
  575.     do (let ((new-members (reproduce (reproduction-technique population-module)
  576.                      reproduction-module)))
  577.          (insert-population-members population-module new-members)
  578.          (update-fitness-list (fitness-technique population-module)))
  579.     finally (if (stop-run? population-module)
  580.             (loop for item in (stop-run? population-module)
  581.               do (print item)))))
  582.  
  583.  
  584. ;************************************************************
  585.  
  586. ;;;     RETRIEVAL FUNCTIONS AND TESTS
  587.  
  588. (defmethod GET-PARENT ((population-module basic-population-module))
  589.   "Return a parent."
  590.   (get-parent (parent-selection-technique population-module)))
  591.  
  592.  
  593. (defmethod TERMINATE-RUN-TEST ((population-module basic-population-module))
  594.   "The default method is to stop a run when the number of
  595. evaluations equals or exceeds the number of desired trials."
  596.   (or (stop-run? population-module)
  597.       (>= (current-index population-module)
  598.       (desired-trials population-module))))
  599.  
  600.  
  601. ;;; Since the population isn't a list, this builds and returns
  602. ;;; the list.
  603. (defmethod POPULATION ((population-module basic-population-module))
  604.   (do ((member (last-member population-module) (predecessor member)) ;We're going backwards...
  605.        (list nil))
  606.       ((null member) list)
  607.     (push member list)))
  608.  
  609.  
  610. ;;; Same for the population in reverse.
  611. (defmethod REVERSE-POPULATION ((population-module basic-population-module))
  612.   (do ((member (first-member population-module) (successor member)) ;We're going backwards...
  613.        (list nil))
  614.       ((null member) list)
  615.     (push member list)))
  616.  
  617.  
  618. ;;; Return a list of the population members' evaluations.
  619. (defmethod EVALUATIONS ((population-module basic-population-module))
  620.   (map-over-elements 'evaluation population-module))
  621.  
  622.  
  623.  
  624. ;************************************************************
  625.  
  626. ;    PERIODIC STATE DISPLAY
  627.  
  628.  
  629. ;;; The periodic state display routine displays the state of the
  630. ;;; GA periodically if the display flag is non-null.  It also
  631. ;;; displays the state after population is initialized and when
  632. ;;; the run has been terminated.
  633.  
  634. (defmethod INITIALIZE-POPULATION :AFTER
  635.        ((display-state-routine periodic-state-display))
  636.   (if (display-flag display-state-routine)
  637.       (format *standard-output*
  638.           "~%~%AT ~a POPULATION IS INITIALIZED WITH BEST EVALUATION ~a"
  639.           (current-index display-state-routine)
  640.           (evaluation (first-member display-state-routine)))))
  641.  
  642.  
  643. (defmethod INSTALL-MEMBER :AFTER
  644.        ((display-state-routine periodic-state-display) member)
  645.   "Display the current population sorted by evaluation"
  646.   (declare (ignore member))
  647.   (if (even-multiple (current-index display-state-routine)
  648.              (display-period display-state-routine))
  649.       (if (display-flag display-state-routine)
  650.          (display-state display-state-routine))))
  651.  
  652.  
  653. (defmethod TERMINATE-RUN :AFTER ((display-state-routine periodic-state-display))
  654.   "Ensure that we display the final state."
  655.   (if (not (even-multiple (current-index display-state-routine)
  656.               (display-period display-state-routine)))
  657.       (if (display-flag display-state-routine)
  658.       (display-state display-state-routine))))
  659.  
  660.  
  661. (defmethod DISPLAY-STATE ((display-state-routine periodic-state-display))
  662.   "This method should be specialized for the application."
  663.   (format *standard-output* "~%~%~%AT ~a BEST ~a CHROMOSOMES ARE:~%"
  664.       (current-index display-state-routine)
  665.       (number-to-display display-state-routine))
  666.   (loop for member in (firstn (number-to-display display-state-routine)
  667.              (population display-state-routine))
  668.     do (if  (null member) t
  669.         (display-member
  670.           (representation-technique display-state-routine) member))))
  671.  
  672.  
  673.  
  674. ;************************************************************
  675.  
  676. ;    PERIODIC PERFORMANCE STATISTICS COLLECTION
  677.  
  678. ;;; These routines collect statistics periodically.  Use the
  679. ;;; average-performance method to get an average of the
  680. ;;; performance across runs.
  681.  
  682. (defmethod INITIALIZE-POPULATION :BEFORE
  683.        ((population-module performance-statistics-collection))
  684.   (setf (performance-statistics population-module)
  685.     (push '() (performance-statistics population-module))))
  686.  
  687.  
  688. (defmethod INSTALL-MEMBER :AFTER 
  689.        ((population-module performance-statistics-collection) member)
  690.   (declare (ignore member))
  691.   (if (even-multiple (current-index population-module)
  692.              (performance-statistics-interval population-module))
  693.       (push (list (current-index population-module)
  694.             (evaluation (first-member population-module)))
  695.           (car (performance-statistics population-module)))))
  696.  
  697.  
  698. (defmethod RUN :AFTER ((population-module performance-statistics-collection))
  699.   "Ensure that we collect the statistics for the final state."
  700.   (if (= (current-index population-module)
  701.      (caaar (performance-statistics population-module)))
  702.       t
  703.       (push (list (current-index population-module)
  704.           (evaluation (first-member population-module)))
  705.         (car (performance-statistics population-module)))))
  706.  
  707.  
  708. (defmethod AVERAGE-PERFORMANCE
  709.        ((population-module performance-statistics-collection))
  710.   (average-cadrs (performance-statistics population-module)))
  711.  
  712.  
  713.  
  714. ;************************************************************
  715.  
  716. ;    EVALUATION MODULE
  717.  
  718.  
  719. ;;; The evaluation module returns evaluations.  The user should
  720. ;;; define the evaluator.  (See examples in the HOW-TO-EXAMPLES
  721. ;;; file.)
  722.  
  723. (defmethod EVALUATE-MEMBER ((evaluation-module basic-evaluation-module) member)
  724.   (evaluate-member (evaluator evaluation-module) member))
  725.  
  726.  
  727. (defmethod INITIALIZE-FOR-RUN ((evaluation-module basic-evaluation-module))
  728.   (setf (evaluation-module (evaluator evaluation-module)) evaluation-module))
  729.  
  730.  
  731.  
  732. ;;; The following are routines for recycling population members, thereby 
  733. ;;; cutting down on garbage collection and object creation requirements.
  734.  
  735. ;;; Note that there is potential for errors creeping in if population
  736. ;;; member fields are not cleared when they are recycled.  The user should
  737. ;;; be careful to clear additional fields of user-defined population member
  738. ;;; classes with :AFTER RESET methods similar to those below.
  739.  
  740. ;;; NOTE ALSO THAT RECYCLING SHOULD NOT BE USED WITH THE ADAPTIVE 
  741. ;;; PARAMETERIZATION UTILITIES, NOR WITH ANY SYSTEM REQUIRING GENEALOGY
  742. ;;; MAINTENANCE.
  743.  
  744. ;;; To turn off the recycling procedures, set the
  745. ;;; *recycle-members-flag* to nil.  
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  
  754. (defmethod RESET ((member population-member))
  755.   "Clear the member fields."
  756.   (setf (evaluation member) nil
  757.     (chromosome member) nil    
  758.     (index member) nil
  759.     (population-module member) nil))
  760.  
  761.  
  762. (defmethod RESET :AFTER ((member doubly-linked-list-element))
  763.   "Chop pointers to predecessor and successor"
  764.   (setf (predecessor member) nil
  765.     (successor member) nil))
  766.  
  767.